SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00018 1 08-24-9413:21ALL TODD JACOBS Basic-like Strings SWAG9408 Ñ£º 14 ^& {π *****************************************************************π * Basic Strings *π * by *π * Todd A. Jacobs *π * *π * Duplicates the Basic string functions Left$, Right$, and Mid$ *π *****************************************************************ππ A very simple unit to assist in parsing strings using familiarπ Basic commands. StrName is self-explanatory. NumChars is theπ length of the string to be returned, and StartPos is the index toπ start at for the Mid$ (aka MidStr) function.ππ Released into the public domain, I hope someone will: a) find itπ useful, and b) add support for comma-delimited and space-delimitedπ input (a la Basic).ππ Comments may be directed to 1:109/182 or tjacobs@epub.com.π Flames may be directed to the NUL device. :)π}ππUnit BasicStr;ππInterfaceππFunction MidStr ( StrName: String; StartPos, NumChars : Integer) : String;πFunction LeftStr ( StrName: String; NumChars : Integer) : String;πFunction RightStr( StrName: String; NumChars : Integer) : String;ππImplementationππFunction MidStr;πBeginπ MidStr := Copy ( StrName, StartPos, NumChars);πEnd; {Mid$}ππFunction LeftStr;πBeginπ LeftStr := Copy ( StrName, 1, NumChars);πEnd; {Left$}ππFunction RightStr;πBeginπ RightStr := Copy ( StrName, ( Length(StrName) - (NumChars - 1)), NumChars);πEnd; {Right$}ππEnd. {Unit}π 2 08-24-9413:28ALL SWAG SUPPORT TEAM Clean String SWAG9408 ▀Fφb 10 ^& function Str2Int(Str:string): integer;πvarπ temp,code : integer;πbeginπ if length(Str) = 0 thenπ Str2Int := 0π else beginπ val(Str,temp,code);π if code = 0 thenπ Str2Int := tempπ elseπ Str2Int := 0;π end;πend;ππfunction StripFrontChars(Var S : String;Ch : Char) : String;πvarπ S1 : String;πbeginπ While (S[1] = Ch) and (Length(S) > 0) doπ S := Copy(S,2,Length(S) - 1);π StripFrontChars := Sπend;ππfunction StripBlanks(Var S : String) : String;πvarπ i : Integer;πbeginπ i := Length(S);π while S[i] = ' ' do beginπ Delete(S,i,1);π Dec(i);π end;π StripBlanks := S;πend;ππfunction CleanString(var S: String): String;πbeginπ StripFrontChars(S, #32);π StripBlanks(S);πend;ππvarπ S: String;π i: Integer;πbeginπ S := ' 3 '; { Create a bad string that will cause errors }π CleanString(S); { Clean it up }π i := Str2Int(S); { Convert }π WriteLn(i); { Show it to the screen }πend. 3 08-24-9413:28ALL RICKY BOOTH Adding Commas To Format SWAG9408 Öïü┘ 9 ^& {π > says how big the file is it says it like 34443 and I wasπ > wonderingπ > is there a command or something I can add in TP6 to make it readπ > 34,443 where it detects where to add a commas. I know there isπ}πProgram Comma;ππUses Crt;ππVar x : longint;π Y : string;ππFunction CommaNum ( I : LongInt ) : String;πVarπ TmpString : String;π Counter, Tester : Byte;πBeginπ TmpString := '';π Counter := 0;π Tester := 0;π Str (i, TmpString);π For Counter := Length (TmpString) Downto 1 Doπ Beginπ Inc (Tester);π If Tester = 3 Thenπ Beginπ Tester := 0;π Dec (Counter);π TmpString := Copy (TmpString, 1, Counter) + ','π + Copy (TmpString, Counter + 1, Length (TmpString) );π Inc (Counter);π End;π End;π If TmpString[1] = ',' THEN DELETE(TmpString,1,1);π CommaNum := TmpString;πEnd;ππBeginπClrScr;πWrite('Enter a number ---> ');πReadln(x);πY := COMMANUM(X);πWrite('Here it is with COMMAS! ---> ');πWrite(y);πReadln;πEnd.π 4 08-24-9413:38ALL CHRIS PRIEDE FLIPPING A STRING SWAG9408 ╒¡╝ 5 ^& {π Thanks but I already wrote a string flipping function, I asked for aπ BASM or Assembler function for optimized speed.π}ππfunction FlipStr(S:string):string; ASSEMBLER;πASMπ les di,@Resultπ mov dx,dsπ lds si,Sπ xor ax,axπ cldπ lodsbπ mov [di],alπ add di,axπ mov cx,axπ jcxz @Doneπ@@1: cldπ lodsbπ stdπ stosbπ loop @@1π mov ds,dxπEND;πππ 5 08-24-9413:45ALL JOSE CAMPIONE Longints in Pascal SWAG9408 YO┤W 25 ^& π typeπ long = array[0..3] of byte; {defines the fake-longint type}π string8 = string[8];ππ {translate the significant portion of a real into a long var}π procedure real2long(r:real; var l:long; var e:boolean);π typeπ string8 = string[8];π string32 = string[32];π varπ s : string32;ππ function power(b:real; x:integer; var e:boolean): real;π beginπ if b > 0 then π power:= exp(x * ln(b))π else halt;π end;ππ {translate the significant portion of a real into a binary string32}π procedure intreal2binstr(r:real; var s:string32; var e:boolean);π varπ i : integer;π m : real;π p : real;π beginπ e:= false;π if (r > power(2,32,e)-1) then beginπ e:= true;π exit;π end;π s:= '';π for i:= 31 downto 1 do beginπ p:= power(2,i,e);π m:= int(r/p);π r:= r - (m * p);π if (int(m) = 0) then s:= s + '0'π else s:= s + '1';π end;π m:= int(r);π r:= r - m;π if (int(m) = 0) then s:= s + '0'π else s:= s + '1';π end; ππ {translate a binary string32 into a long variable}π procedure binstr2long(s: string32; var l:long; var e:boolean);π varπ i : integer;π w : string[8];π b : byte;π π {translate a binary string8 into a byte}π procedure binstr2byte(s:string8; var y:byte; var e:boolean);π varπ i : integer;π v : integer;π c : integer;π b : byte;π beginπ y:= 0;π for i:= 1 to 8 do beginπ val(s[i],v,c);π e:= not(c = 0);π if e then exit;π b:= v * trunc(power(2,(8-i),e));π y:= y or b;π end;π end;ππ begin {binstr2long}π for i:= 0 to 3 do beginπ w:= copy(s,(i*8)+1,8);π binstr2byte(w,b,e);π l[3 - i]:= b;π end;π end;ππ begin {real2long}π intreal2binstr(r,s,e);π if e then exit;π binstr2long(s,l,e);π if e then exit;π end;ππ {translate a string8 (a number in hex notation) into a long variable} π procedure str2long(s:string8; var l:long; var e: boolean);π varπ i : integer;π c : integer;π v : integer;π sb : array[0..3] of string[3];π beginπ for i:= 0 to 3 do beginπ sb[i]:= '$' + copy(s,(7-(i*2)),2);π val(sb[i],v,c);π e:= not(c = 0);π if e then exit;π l[i]:= v;π end;π end;ππ {translate an integer into a long variable}π procedure int2long(i:integer; var l: long);π beginπ fillchar(l,sizeof(l),0);π move(i,l,2);π end;ππ {"shr 8" for long variables}π procedure shr8(var a,b: long);π varπ i : integer;π beginπ for i:= 0 to 2 doπ b[i]:= a[(i+1)];π b[3]:= 0;π end;ππ {"xor" for long variables}π procedure xorl(var a,b,c : long);π varπ i : integer;π beginπ for i:= 0 to 3 doπ c[i]:= a[i] xor b[i];π end;ππ {"and" for long variables}π procedure andl(var a,b,c : long);π varπ i : integer;π beginπ for i:= 0 to 3 doπ c[i]:= a[i] and b[i];π end;ππBEGINπEND. 6 08-24-9413:49ALL MARIO POLYCARPOU number conversion SWAG9408 ·▄ 19 ^& {π JS> I, remember way back which could be a while I saw a basic routineπ JS> that would convert numbers to their written form like 120= oneπ JS> hundred and twenty. If anyone has such a routine it would beπ JS> appreciated..πππ This was quite a challenge..I did find a bug so have a look at theπ test. To really put this to the test you'd have to get it to returnπ every single number (0-64K) and observe the output.πππ{Returns the written format of any number between 0-65535}π{ Could be useful in a checkbook program }ππUSES Crt;ππ{----------------------------------------------------}πFUNCTION LZ(Num:Word; Times:Byte; Ch:Char):String;πVAR S:String;πBEGINπ Str(Num,S); WHILE Length(S)<Times DO S:=Ch+S; LZ:=S;πEND;π{------------------------------------------------}πFUNCTION Convert(Num:Word):String;πCONSTπ Hu='hundred'; Th='thousand';π Units:Array[0..9] OF String[5]= {60 bytes}π ('','one','two','three','four','five','six','seven','eight','nine');π Tens:Array[0..9] OF String[7]= {80 bytes}π ('','ten,','twenty','thirty','fourty','fifty','sixty','seventy','eighty',π 'ninety');π Ones:Array[0..9] OF String[9]= {100 bytes}π ('','eleven','twelve','thirteen','fourteen','fifteen','sixteen',π 'seventeen','eighteen','nineteen');πVAR S1,S2:String; X:Byte;πBEGINπ S1:=LZ(Num,5,' '); S2:='';π FOR Num:=Length(S1) DOWNTO 1 DOπ IF S1[Num]<>' ' THENπ BEGINπ X:=Ord(S1[Num])-48;π CASE Num OFπ 1: S2:=Tens[X]+' '+S2;π 2: IF S1[1]='1' THENπ BEGINπ S2:=Ones[X]+' '+Th+' '+S2; Break;π END ELSE S2:=Units[X]+' '+Th+' '+S2;π 3: IF S1[3]='0' THENπ BEGINπ IF (S1[2]<>'0') AND (S1[1]<>' ') THEN S2:='and '+S2;π END ELSEπ IF S1[4]<>'0' THEN S2:=Units[X]+' '+Hu+' and '+S2π ELSE S2:=Units[X]+' '+Hu;π 4: S2:=Tens[X]+' '+S2;π 5: IF S1[4]='1' THENπ BEGINπ S2:=Ones[X]; Break;π END ELSE S2:=Units[X];π END;π END; Convert:=S2;πEND;π{------------------------------------------------}πBEGINπ ClrScr;π Writeln(Convert(23452)); {ok}π Writeln(Convert(60201)); {Bug!}π Writeln(Convert(9900)); {ok}π Writeln(Convert(534)); {ok}π Writeln(Convert(18770)); {ok}π Writeln(Convert(4)); {ok}πEND.π 7 08-24-9413:51ALL GREG VIGNEAULT PosIn() SWAG9408 ² ║═ 30 ^& {π Here's a routine that's faster than Pos on my system. It's writtenπ in external assembly language, and linked directly into TP programπ code. I'm including an example of using the code, the assemblyπ source code, and a pre-assembled ready-to-compile POSIN.OBJ file:ππ Here's the example... }ππ(*******************************************************************)πPROGRAM Demo; { A faster Pos() for TP4+. June 17/94 Greg Vigneault }ππVAR str : STRING; j : BYTE;ππFUNCTION PosIn (Pattern, Str : STRING) : BYTE; EXTERNAL;π{$L POSIN.OBJ} (* link in the external code *)ππBEGINπ WriteLn;π str := 'Position of THIS in string is ';π j := PosIn ('THIS',str);; WriteLn (str,j);π WHILE (j > 1) DO BEGIN Write (' '); DEC(j); END;π WriteLn ('^^^^');π WriteLn;πEND.π(*******************************************************************)ππHere's the assembly code source...π;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;πcode segment byte public 'CODE'π assume cs:codeπ; FUNCTION PosIn (pattern, string : STRING) : BYTE;πpattern equ dword ptr 8[bp]πstring equ dword ptr 4[bp]πPosIn proc nearπ public PosInπ push bp ; preserveπ mov bp, spπ push dsπ push esπ cld ; assure forward scansπ lds si, pattern ; DS:SI -> patternπ sub ax, ax ; zeroπ lodsb ; get length byteπ test ax, ax ; null string?π jz done ; yes: exit with zeroπ mov dx, ax ; length of patternπ les di, string ; ES:DI -> stringπ sub bx, bx ; zeroπ mov bl, es:[di] ; string lengthπ cmp bx, dx ; pattern > string ?π jc none ; yes: exit with zeroπ inc di ; point to 1st string charπ lodsb ; get pattern 1st charπ dec dx ; adjust pointerπ sub bx, dx ; don't need to check endπ po0: mov cx, bx ; unsearched chars countπ repne scasb ; search for pattern charπ jne none ; no char matchπ mov bx, cx ; unsearched countπ push di ; save text pointersπ push siπ mov cx, dx ; length of patternπ repe cmpsb ; check for patternπ pop si ; restore pointersπ pop diπ jne po0 ; loop if no pattern matchπ lds ax, string ; string pointerπ xchg ax, di ; swap offsetsπ sub ax, di ; subtract offsetsπ dec ax ; adjust for PosInπ jmp short done ; found patternπ none: sub ax, ax ; pattern not foundπ done: pop es ; restoreπ pop dsπ mov sp, bpπ pop bpπ ret 8πPosIn endpπcode endsπ endπ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;ππUSE XX3402 to decode this and obtain POSIN.OBJ requried for this unit.ππ*XX3402-000140-170694--72--85-37398-------POSIN.OBJ--1-OF--1πU+g+0L-jQqZi9Y3HHHGK-k++-2BDF2J2a+Q+82U++U6-v7+A+++--J-DIoZC++++pMU2++0Wπ+R4UH++-++-JWykS-jn3RUUfk8m3k5EkWx12TUEfqmO85HjOQW-5f2cfqcj9wetp3MjNJpO9πmjCaLZxpvgJ4-7QfloXf+Wj+-ly9tJr00+1nWU6++5E+π***** END OF BLOCK 1 *****ππ 8 08-24-9413:51ALL EDDY THILLEMAN Pos() in asm SWAG9408 k C 23 ^& πvarπ s1, s2: string;π position: byte;ππfunction StrPos( var str1, str2: string ): byte; assembler;π { returns position of the first occurrence of str1 in str2 }π { return value in AL }π { str1 - string to search for }π { str2 - string to search in }πasmπ CLD { string operations forward }π LES DI,Str2 { load in ES:DI pointer to str2 }π XOR CH,CH { clear CH }π MOV CL,[DI] { length str2 --> CL }π AND CL,CL { length str2 = 0? }π JZ @Negatief { length str2 = 0, nothing to search in }π MOV BH,CL { length str2 --> BH }π INC DI { make DI point to the 1st char of str2 }π LDS SI,Str1 { load in DS:SI pointer to str1 }π LODSB { load in AL length str1 }π AND AL,AL { length str1 = 0? }π JZ @Negatief { length str1 = 0, nothing to search for }π DEC AL { 1st char need not be compared again }π SUB CL,AL { length str2 - length str1 }π JBE @Negatief { length str2 < length str1 }π MOV AH,AL { length str1 --> AH }π LODSB { load in AL 1st character of str1 }π@Start:π REPNE SCASB { scan for next occurrence 1st char in str2 }π JNE @Negatief { no success }π MOV DX,SI { pointer to 2nd char in str1 --> DX }π MOV BL,CL { number of chars in str2 to go --> BL }π MOV CL,AH { length str1 --> CL }π REPE CMPSB { compare until characters don't match }π JE @Positief { full match }π SUB SI,DX { current SI - prev. SI = # of chars moved }π SUB DI,SI { current DI - # of chars moved = prev. DI }π MOV SI,DX { restore pointer to 2nd char in str1 }π MOV CL,BL { number of chars in str2 to go --> BL }π JMP @Start { scan for next occurrence 1st char in str2 }π@Negatief:π XOR AX,AX { str1 is not in str2, result 0 }π JMP @Exitπ@Positief:π ADD BL,AH { number of chars in str2 left }π MOV AL,BH { length str2 --> AX }π SUB AL,BL { start position of str1 in str2 }π@Exit: { we are finished. }πend { StrPos };ππbeginπ s1 := ParamStr( 1 );π s2 := ParamStr( 2 );π writeln( StrPos( s1, s2 ) );πend.ππ 9 08-24-9413:59ALL EDDY THILLEMAN Basm string routines SWAG9408 ÷╥Q╝ 22 ^& πprocedure CopySubStr( Str1: string; start, nrchars: byte; var Str2: string );πassembler;π { copy part of Str1 (beginning at start for nrchars) to Str2π if start > length of Str1, Str2 will contain a empty string.π if nrchars specifies more characters than remain starting at theπ start position, Str2 will contain just that remainder of Str1. }πasmπ { setup }π LDS SI,Str1 { load in DS:SI pointer to str1 }π CLD { string operations forward }π LES DI,Str2 { load in ES:DI pointer to str2 }π MOV AH,[SI] { length str1 --> AH }π AND AH,AH { length str1 = 0? }π JE @null { yes, empty string in Str2 }π MOV BL,[start] { starting position --> BL }π CMP AH,BL { start > length str1? }π JB @null { yes, empty string in Str2 }ππ { start + nrchars - 1 > length str1? }π MOV AL,[nrchars] { nrchars --> AL }π MOV DH,AL { nrchars --> DH }π ADD DH,BL { add start }π DEC DHπ CMP AH,DH { nrchars > rest of str1? }π JB @rest { yes, copy rest of str1 }π JMP #copyπ@null:π MOV AL,0 { return a empty string }π JMP #doneπ@rest:π SUB AH,BL { length str1 - start }π INC AHπ MOV AL,AHπ@copy:π MOV CL,AL { how many chars to copy }π XOR CH,CH { clear CH }π XOR BH,BH { clear BH }π ADD SI,BX { starting position }π MOV DX,DI { save pointer to str2 }π INC DIπ REP MOVSB { copy part str1 to str2 }π MOV DI,DX { restore pointer to str2 }π@done:π MOV [DI],AL { overwrite length byte of str2 }π@exit:πend { CopySubStr };πππprocedure StrCopy( var Str1, Str2: string ); assembler;π { copy str1 to str2 }πasmπ LDS SI,Str1 { load in DS:SI pointer to str1 }π CLD { string operations forward }π LES DI,Str2 { load in ES:DI pointer to str2 }π XOR CH,CH { clear CH }π MOV CL,[SI] { length str1 --> CX }π INC CX { include length byte }π REP MOVSB { copy str1 to str2 }π@exit:πend { StrCopy };π 10 08-24-9413:59ALL LUIS MEZQUITA Flipping a String SWAG9408 ÷╒ª 15 ^& πProcedure ReverseString(var s:string);πvar i,j:byte; c:char;πbeginπ j:=Length(s);π for i:=1 to j div 2 doπ beginπ c:=s[i];π s[i]:=s[j];π s[j]:=c;π dec(j);π end;πend;ππ{ ---- BASM 'pointer oriented' version ------------------------------ }πProcedure ReverseAString(var s:string); assembler;πasmπ lds SI,sπ mov AL,[SI]π xor AH,AHπ mov DI,SIπ inc SI { SI points to start of s }π add DI,AX { DI points to end of s }ππ@@0: cmp SI,DI { while SI=DI do ... }π jae @@1ππ mov AL,[SI]π mov AH,[DI]π mov [SI],AHπ mov [DI],ALπ inc SIπ dec DIπ jmp @@0π@@1:πend;ππ{ Version #2 }ππProcedure ReverseAString(var s:string); assembler;πasmπ push DSπ cldπ lds SI,sπ mov DI,SIπ lodsbπ xor AH,AHπ add DI,AX { DI points to end of s }π@ReverseLoop: cmp SI,DI { while SI=DI do ... }π jae @ReverseExitπ mov AL,[SI]π mov AH,[DI]π mov [SI],AHπ mov [DI],ALπ inc SIπ dec DIπ jmp @ReverseLoopπ@ReverseExit: pop DSπend;ππFunction FlipStr(s:string):string; assembler;πasmπ push DSπ cldπ les DI,@Resultπ lds SI,sπ lodsbπ stosbπ mov CL,ALπ xor CH,CHπ add DI,CXπ@FlipLoop: and CL,CLπ jz @FlipExitπ lodsbπ dec DIπ mov ES:[DI],ALπ dec CLπ jmp @FlipLoopπ@FlipExit: pop DSπend;π 11 08-24-9417:57ALL EDDY THILLEMAN Byte string w/lead zero SWAG9408 ú!╠│ 12 ^& {πFor this sort program, I needed a routine to convert a byte value into aπstring with leading zeros. So I made one in BASM: Byte2lzStr. If you want,πinclude this routine in SWAG.π}ππvar s: string;π tel, n : byte;ππprocedure Byte2lzStr( n, width: byte; var str: string ); assembler;π { Byte to string with leading zeros }πasmπ std { string operations backwards }π mov al, [n] { numeric value to convert }π mov cl, [width] { width of str }π xor ch, ch { clear ch }π les di, str { adress of str }π mov [di], cl { length of str }π add di, cx { start with last char str }π@start: jcxz @exit { done? }π aam { divide al by 10 }π add al, 30h { convert remainder to char }π stosb { store digit }π xchg al, ah { swap remainder and quotient }π dec cl { count down }π jmp @start { next digit }π@exit:πend { Byte2lzStr };ππbeginπ randomize;π for tel := 1 to 24 doπ beginπ n := random( 256 );π Byte2lzStr( n, 5, s );π writeln( tel:2,': ', n:3,' ', s,' [',length(s),']' );π end;πend.π 12 08-25-9409:05ALL EDDY THILLEMAN Basm routines SWAG9408 É}~) 93 ^& procedure CopySubStr( Str1: string; start, nrchars: byte; var Str2: string );πassembler;π { copy part of Str1 (beginning at start for nrchars) to Str2π if start > length of Str1, Str2 will contain a empty string.π if nrchars specifies more characters than remain starting at theπ start position, Str2 will contain just that remainder of Str1. }πasmπ { setup }π LDS SI,Str1 { load in DS:SI pointer to str1 }π CLD { string operations forward }π LES DI,Str2 { load in ES:DI pointer to str2 }π MOV AH,[SI] { length str1 --> AH }π AND AH,AH { length str1 = 0? }π JE @null { yes, empty string in Str2 }π MOV BL,[start] { starting position --> BL }π CMP AH,BL { start > length str1? }π JB @null { yes, empty string in Str2 }ππ { start + nrchars - 1 > length str1? }π MOV AL,[nrchars] { nrchars --> AL }π MOV DH,AL { nrchars --> DH }π ADD DH,BL { add start }π DEC DHπ CMP AH,DH { nrchars > rest of str1? }π JB @rest { yes, copy rest of str1 }π JMP @copyπ@null:π MOV AL,0 { return a empty string }π JMP @doneπ@rest:π SUB AH,BL { length str1 - start }π INC AHπ MOV AL,AHπ@copy:π MOV CL,AL { how many chars to copy }π XOR CH,CH { clear CH }π XOR BH,BH { clear BH }π ADD SI,BX { starting position }π MOV DX,DI { save pointer to str2 }π INC DIπ REP MOVSB { copy part str1 to str2 }π MOV DI,DX { restore pointer to str2 }π@done:π MOV [DI],AL { overwrite length byte of str2 }π@exit:πend { CopySubStr };πππprocedure StrCopy( var Str1, Str2: string ); assembler;π { copy str1 to str2 }πasmπ LDS SI,Str1 { load in DS:SI pointer to str1 }π CLD { string operations forward }π LES DI,Str2 { load in ES:DI pointer to str2 }π XOR CH,CH { clear CH }π MOV CL,[SI] { length str1 --> CX }π INC CX { include length byte }π REP MOVSB { copy str1 to str2 }π@exit:πend { StrCopy };ππfunction StrPos( var str1, str2: string ): byte; assembler;π { returns position of the first occurrence of str1 in str2 }π { return value in AX }π { str1 - string to search for }π { str2 - string to search in }πasmπ CLD { string operations forward }π LES DI,Str2 { load in ES:DI pointer to str2 }π XOR CH,CH { clear CH }π MOV CL,[DI] { length str2 --> CX }π AND CX,CX { length str2 = 0? }π JZ @Negatief { length str2 = 0, nothing to search in }π INC DI { make DI point to the 1st char of str2 }π LDS SI,Str1 { load in DS:SI pointer to str1 }π LODSB { load in AL length str1 }π AND AL,AL { length str1 = 0? }π JZ @Negatief { length str1 = 0, nothing to search for }π MOV AH,AL { length str1 --> AH }π DEC AH { 1st char need not be compared again }π LODSB { load in AL 1st character of str1 }π@Start:π REPNE SCASB { scan for next occurrence 1st char in str2 }π JNE @Negatief { no success }π CMP CL,AH { length str1 > # chars left in str2 ? }π JB @Negatief { yes, str1 not in str2 }π MOV DX,SI { pointer to 2nd char in str1 --> DX }π MOV BX,CX { number of chars in str2 to go --> BX }π MOV CL,AH { length str1 --> CL }π REPE CMPSB { compare until characters don't match }π JE @Positief { full match }π SUB SI,DX { current SI - prev. SI = # of chars moved }π SUB DI,SI { reconstruct DI }π MOV SI,DX { restore pointer to 2nd char in str1 }π MOV CX,BX { number of chars in str2 to go --> BX }π JMP @Start { scan for next occurrence 1st char in str2 }π@Negatief:π XOR AX,AX { str1 is not in str, result 0 }π JMP @Exitπ@Positief:π XOR AH,AH { clear AH }π LES DI,Str2 { load in ES:DI pointer to str2 }π MOV AL,[DI] { length str2 --> AX }π SUB AX,BX { start position of str1 in str2 }π@Exit: { we are finished. }πend { StrPos };ππprocedure Trim( var Str: string ); assembler;π { remove leading and trailing white space from str }πasmπ { setup }π LDS SI,Str { load in DS:SI pointer to Str }π MOV AX,DS { Set ES to same segment as DS }π MOV ES,AX { Set ES to same segment as DS }π MOV AL,[SI] { length Str --> AL }π AND AL,AL { length Str = 0? }π JZ @exit { yes, nothing to do }π MOV DI,SI { pointer to Str --> DI }π MOV AH,AL { length Str --> AH }ππ { remove trailing white space }π XOR CH,CH { clear CH }π MOV CL,AH { length Str --> CX }π ADD SI,CX { start with last character }π@start1:π MOV AL,[SI] { character --> AL }π CMP AL,20H { no white space }π JA @stop1 { last non-blank character found }π DEC SI { count down SI }π DEC CL { count down CX }π AND CL,CL { more characters left? }π JZ @stop1 { no, done }π JMP @start1 { try again }π@stop1:π AND CL,CL { length Str = 0? }π JZ @done { string is empty, done }ππ { look for leading white space }π MOV SI,DI { pointer to Str --> SI }π@start2:π INC SI { next character }π MOV AL,[SI] { character --> AL }π CMP AL,20H { no white space }π JA @stop2 { first non-blank character found }π DEC CL { count down }π AND CL,CL { more characters left? }π JZ @stop2 { no, done }π JMP @start2 { try again }π@stop2:π MOV DX,SI { difference between SI and DI gives }π SUB DX,DI { position first non-blank character }π CMP DX,1 { first character non-blank? }π JE @done { yes, done }ππ { remove leading white space }π CLD { string operations forward }π MOV BX,CX { save length Str }π MOV DX,DI { save pointer to Str }π INC DI { don't overwrite length byte of Str }π REP MOVSB { move remaining part of Str }π MOV DI,DX { restore pointer to Str }π MOV CX,BX { restore length Str }π@done:π MOV [DI],CL { overwrite length byte of Str }π@exit:πend { Trim };πππprocedure RTrim( var Str: string ); assembler;π { remove trailing white space from str }πasmπ { setup }π LDS SI,Str { load in DS:SI pointer to Str }π MOV AL,[SI] { length Str --> AL }π AND AL,AL { length Str = 0? }π JZ @exit { yes, exit }π MOV DI,SI { pointer to Str --> DI }π MOV AH,AL { length Str --> AH }ππ { remove trailing space }π STD { SeT Direction flag --> backwards }π XOR CH,CH { clear CH }π MOV CL,AH { length Str --> CX }π ADD SI,CX { start with last character }π@start:π MOV AL,[SI] { character --> AL }π CMP AL,20H { no white space }π JA @stop { last non-blank character found }π DEC SI { count down }π DEC CL { count down }π AND CL,CL { more characters left? }π JZ @stop { no, done }π JMP @start { try again }π@stop:π MOV [DI],CL { overwrite length byte of Str }π@exit:πend { RTrim };πππprocedure LTrim( var Str: string ); assembler;π { remove leading white space from str }πasmπ { setup }π LDS SI,Str { load in DS:SI pointer to Str }π MOV AL,[SI] { length Str --> AL }π AND AL,AL { length Str = 0? }π JZ @exit { yes, nothing to do }π MOV DI,SI { pointer to Str --> DI }π XOR CH,CH { clear CH }π MOV CL,AL { length Str --> CX }ππ { look for leading white space }π@start:π INC SI { next character }π MOV AL,[SI] { character --> AL }π CMP AL,20H { no white space }π JA @stop { first non-blank character found }π DEC CL { count down }π AND CL,CL { more characters left? }π JZ @nullstr { no, done }π JMP @start { try again }π@nullstr:π MOV CL,0 { null string }π JMP @done { we're done }π@stop:π MOV DX,SI { difference between SI and DI gives }π SUB DX,DI { position first non-blank character }π CMP DX,1 { first character non-blank? }π JE @exit { yes, exit }ππ { remove leading white space }π CLD { string operations forward }π MOV DX,CX { save length Str }π MOV BX,DI { save pointer to Str }π INC DI { don't overwrite length byte of Str }π REP MOVSB { move remaining part of Str }π MOV DI,BX { restore pointer to Str }π MOV CX,DX { restore length Str }π@done:π MOV [DI],CL { overwrite length byte of Str }π@exit:πend { LTrim };ππ 13 08-25-9409:08ALL BRIAN GRAINGER String Dumps SWAG9408 -~QC 32 ^& {πLH> Very nice - and a dandy tutorial on OOP streaming.ππThanks for the compliment.ππLH> My little step-up speeds things up by 3x, but I imagine yours isπLH> a hefty margin faster than that.ππI further modified the original and my streaming version to send theirπoutputs to a text file. In the original I used a variable of typeπText, and in the streaming version, I used a variable of typeπpBufStream. This was to eliminate any screen scrolling delays. I ranπboth versions on COMMAND.COM, which has a file size of 47845 bytes onπmy system. In going back over my code, I also noticed that I hadπdeclared the read buffer as vInByte: BYTE. I changed this to vInChar:πCHAR and eliminated the call to Chr(vInByte) when appending charactersπto the result string.ππThe original took 243201.838 ms and the streaming version tookπ2351.532 ms to scan the file. The absolute numbers are less importantπthan the ratio, which is 103.423. So in this instance the use ofπstreams and in-memory searching resulted in a speed-up of almost 104x.ππI tried buffer sizes of 512 to 16384 bytes in increments of 512 bytesπand found that 8192 was optimum on my system. The worst buffer sizeπwas 1024 bytes. This required 2765.426 ms to scan the file, anπincrease of 17.6% over the optimum. This was a very interesting andπunexpected result, given that 1024 is the figure used in the TV andπOWL documentation. Of course, this is probably very system dependent.πI run dual IDE drives, one formatted FAT and the other formatted OS/2πHPFS. The above results were obtained off the FAT drive. ππOn the HPFS drive, the best time was turned in by a buffer size ofπ4608 bytes. This size had given the second-best results on the FATπdrive at 2368.464 ms, but clocked in on the HPFS drive at 2373.780.πUsing an 8192 byte buffer on the HPFS drive resulted in a time ofπ2449.082 ms.ππComparing the speeds on the FAT and HPFS drives in this case isn'tπreally apples and apples, since the two drives are from differentπmanufacturers. A better test would be to use two logical partitions onπthe same drive. Even at that though the average boost in speed wasπaround 100x over the original.π}πPROGRAM FindStr;π (* Searches any file for printable strings of 6 or more characters. *)π (* Useful for extracting messages and internal documentation from .EXE's *)ππ USESπ Objects;ππ VARπ vInFile,π vOutFile : pBufStream;π vMemFile : pMemoryStream;π vS : STRING;π vInChar : CHAR;π BEGINπ vInFile := New(pBufStream, Init(ParamStr(1), stOpenRead, 8192));π IF vInFile = NIL THENπ BEGINπ WriteLn('Unable to open input file');π Halt;π END;π vOutFile := New(pBufStream, Init(ParamStr(2), stCreate, 8192));π IF vOutFile = NIL THENπ BEGINπ WriteLn('Unable to create output file');π Dispose(vInFile, Done);π Halt;π END;π vMemFile := New(pMemoryStream, Init(vInFile^.GetSize, 8192));π IF vMemFile = NIL THENπ BEGINπ WriteLn('Insufficient memory');π Dispose(vInFile, Done);π Dispose(vOutfile, Done);π Halt;π END;π vInFile^.Seek(0);π vOutFile^.Seek(0);π vMemFile^.CopyFrom(vInFile^, vInFile^.GetSize);π IF vInFile <> NIL THENπ Dispose(vInFile, Done);π vMemFile^.Seek(0);π WriteLn('>>Searching ', ParamStr(1),'<<');π WITH vMemFile^ DOπ WHILE (Status = stOK) DOπ BEGINπ vS := '';π Read(vInChar, 1);π WHILE ((vInChar > #31) AND (vInChar < #127) AND (Status = stOK)) DOπ BEGINπ vS := vS + vInChar;π Read(vInChar, 1);π END;π IF Length(vS) > 5 THENπ BEGINπ vS := vS + #13#10;π vOutFile^.Write(vS[1], Length(vS));π END;π END;π IF vMemFile <> NIL THENπ Dispose(vMemFile, Done);π IF vOutFile <> NIL THENπ Dispose(vOutFile, Done);π WriteLn('>>End of file<<');π END.π 14 08-25-9409:08ALL EDDY THILLEMAN Inline String Routines SWAG9408 ╤√rÅ 61 ^& {πHow do I make from a procedure or function an inline version?πIf I run the following program, the computer locks up. What's wrong??πHelp!!π}πvarπ s1, s2: string;ππprocedure CopySubStr( Str1: string; start, nrchars: byte; var Str2: string );π { copy part of Str1 (beginning at start for nrchars) to Str2π if start > length of Str1, Str2 will contain a empty string.π if nrchars specifies more characters than remain starting at theπ start position, Str2 will contain just that remainder of Str1. }πInLine(π $55/ { push bp }π $89/$E5/ { mov bp,sp }π $C5/$76/$0C/ { lds si,[bp+0C] }π $FC/ { cld }π $C4/$7E/$04/ { les di,[bp+04] }π $8A/$24/ { mov ah,[si] }π $20/$E4/ { and ah,ah }π $74/$16/ { je @null }π $8A/$5E/$0A/ { mov bl,[bp+0A] }π $38/$DC/ { cmp ah,bl }π $72/$0F/ { jb @null }π $8A/$46/$08/ { mov al,[bp+08] }π $88/$C6/ { mov dh,al }π $00/$DE/ { add dh,bl }π $FE/$CE/ { dec dh }π $38/$F4/ { cmp ah,dh }π $72/$06/ { jb @rest }π $EB/$0A/ { jmp @copy }π { @null: }π $B0/$00/ { mov al,00 }π $EB/$15/ { jmp @done }π { @rest: }π $28/$DC/ { sub ah,bl }π $FE/$C4/ { inc ah }π $88/$E0/ { mov al,ah }π { @copy: }π $88/$C1/ { mov cl,al }π $30/$ED/ { xor ch,ch }π $30/$FF/ { xor bh,bh }π $01/$DE/ { add si,bx }π $89/$FA/ { mov dx,di }π $47/ { inc di }π $F3/$A4/ { rep movsb }π $89/$D7/ { mov di,dx }π { @done: }π $88/$05/ { mov [di],al }π { @exit: }π $5D { pop bp }π) { CopySubStr };ππprocedure StrCopy( var Str1, Str2: string );π { copy str1 to str2 }πInLine(π $89/$EA/ { mov dx,bp }π $89/$E5/ { mov bp,sp }π $C5/$76/$08/ { lds si,[bp+08] }π $FC/ { cld }π $C4/$7E/$04/ { les di,[bp+04] }π $30/$ED/ { xor ch,ch }π $8A/$0C/ { mov cl,[si] }π $41/ { inc cx }π $F3/$A4/ { rep movsb }π $89/$D5 { mov bp,dx }π) { StrCopy };ππfunction StrPos( var str1, str2: string ): byte;π { returns position of the first occurrence of str1 in str2 }π { return value in AX }π { str1 - string to search for }π { str2 - string to search in }πInLine(π $55/ { push bp }π $89/$E5/ { mov bp,sp }π $FC/ { cld }π $C4/$7E/$04/ { les di,[bp+04] }π $30/$ED/ { xor ch,ch }π $8A/$0D/ { mov cl,[di] }π $21/$C9/ { and cx,cx }π $74/$2A/ { je @negatief }π $47/ { inc di }π $C5/$76/$08/ { lds si,[bp+08] }π $AC/ { lodsb }π $20/$C0/ { and al,al }π $74/$21/ { je @negatief }π $88/$C4/ { mov ah,al }π $FE/$CC/ { dec ah }π $AC/ { lodsb }π { @start: }π $F2/$AE/ { repnz scasb }π $75/$18/ { jne @negatief }π $38/$E1/ { cmp cl,ah }π $72/$14/ { jb @negatief }π $89/$F2/ { mov dx,si }π $89/$CB/ { mov bx,cx }π $88/$E1/ { mov cl,ah }π $F3/$A6/ { rep cmpsb }π $74/$0E/ { je @positief }π $29/$D6/ { sub si,dx }π $29/$F7/ { sub di,si }π $89/$D6/ { mov si,dx }π $89/$D9/ { mov cx,bx }π $EB/$E4/ { jmp @start }π { @Negatief: }π $31/$C0/ { xor ax,ax }π $EB/$09/ { jmp @exit }π { @Positief: }π $30/$E4/ { xor ah,ah }π $C4/$7E/$04/ { les di,[bp+04] }π $8A/$05/ { mov al,[di] }π $29/$D8/ { sub ax,bx }π { @Exit: }π $5D { pop bp }π) { StrPos };ππprocedure Trim( var Str: string );π { remove leading and trailing white space from str }πInLine( { setup }π $55/ { push bp }π $89/$E5/ { mov bp,sp }π $C5/$76/$04/ { lds si,[bp+04] }π $8C/$D8/ { mov ax,ds }π $8E/$C0/ { mov es,ax }π $8A/$04/ { mov al,[si] }π $20/$C0/ { and al,al }π $74/$45/ { je @exit }π $89/$F7/ { mov di,si }π $88/$C4/ { mov ah,al }π { remove trailing white space }π $30/$ED/ { xor ch,ch }π $88/$E1/ { mov cl,ah }π $01/$CE/ { add si,cx }π { @start1: }π $8A/$04/ { mov al,[si] }π $3C/$20/ { cmp al,20 }π $77/$09/ { ja @stop1 }π $4E/ { dec si }π $FE/$C9/ { dec cl }π $20/$C9/ { and cl,cl }π $74/$02/ { je @stop1 }π $EB/$F1/ { jmp @start1 }π { @stop1: }π $20/$C9/ { and cl,cl }π $74/$26/ { je @done }π { look for leading white space }π $89/$FE/ { mov si,di }π { @start2: }π $46/ { inc si }π $8A/$04/ { mov al,[si] }π $3C/$20/ { cmp al,20 }π $77/$08/ { ja @stop2 }π $FE/$C9/ { dec cl }π $20/$C9/ { and cl,cl }π $74/$02/ { je @stop2 }π $EB/$F1/ { jmp @start2 }π { @stop2: }π $89/$F2/ { mov dx,si }π $29/$FA/ { sub dx,di }π $83/$FA/$01/ { cmp dx,0001 }π $74/$0C/ { je @done }π $FC/ { cld }π $89/$CB/ { mov bx,cx }π $89/$FA/ { mov dx,di }π $47/ { inc di }π $F3/$A4/ { rep movsb }π $89/$D7/ { mov di,dx }π $89/$D9/ { mov cx,bx }π { @done: }π $88/$0D/ { mov [di],cl }π { @exit: }π $5D { pop bp }π) { Trim };ππbeginπ s1 := '123456789-123456789-';π s2 := '';π CopySubStr( s1, 1, 12, s2 );π writeln( s2 );ππ s1 := '123qqwerty';π s2 := 'qwerty';π CopySubStr( s1, 1, 12, s2 );π writeln( s2 );ππ StrCopy( s1, s2 );π writeln( s2 );ππ s1 := '123456789-123456789-';π s2 := '4567';π writeln( StrPos( s1, s2 ) );ππ s1 := ' 123qqwerty ';π s2 := 'qwerty';π writeln( StrPos( s1, s2 ) );ππ Trim( s1 );π writeln( s2 );πend.π 15 08-25-9409:11ALL EDDY THILLEMAN RPos in BASM SWAG9408 à&=≈ 25 ^& varπ s1, s2: string;ππfunction RPos( var str1, str2: string ): byte; assembler;π { returns position of the last occurrence of str1 in str2 }π { return value in AX }π { str1 - string to search for }π { str2 - string to search in }πasmπ STD { string operations backwards }π LES DI,Str2 { load in ES:DI pointer to str2 }π XOR CH,CH { clear CH }π MOV CL,[DI] { length str2 --> CX }π AND CX,CX { length str2 = 0? }π JZ @Negatief { length str2 = 0, nothing to search in }π ADD DI,CX { make DI point to the last char of str2 }π LDS SI,Str1 { load in DS:SI pointer to str1 }π XOR AH,AH { clear AH }π MOV AL,[SI] { load in AX length str1 }π AND AL,AL { length str1 = 0? }π JZ @Negatief { length str1 = 0, nothing to search for }π ADD SI,AX { make SI point to the last char of str1 }π MOV AH,AL { length str1 --> AH }π DEC AH { last char need not be compared again }π LODSB { load in AL last character of str1 }π@Start:π REPNE SCASB { scan for next occurrence 1st char in str2 }π JNE @Negatief { no success }π CMP CL,AH { length str1 > # chars left in str2 ? }π JB @Negatief { yes, str1 not in str2 }π MOV DX,SI { pointer to last but 1 char in str1 --> DX }π MOV BX,CX { number of chars in str2 to go --> BX }π MOV CL,AH { length str1 --> CL }π REPE CMPSB { compare until characters don't match }π JE @Positief { full match }π SUB SI,DX { }π NEG SI { prev. SI - current SI = # of chars moved }π ADD DI,SI { reconstruct DI }π MOV SI,DX { restore pointer to 2nd char in str1 }π MOV CX,BX { number of chars in str2 to go --> BX }π JMP @Start { scan for next occurrence 1st char in str2 }π@Negatief:π XOR AX,AX { str1 is not in str, result 0 }π JMP @Exitπ@Positief:π INC BLπ SUB BL,AH { start position of str1 in str2 }π MOV AL,BL { in AL }π XOR AH,AH { clear AH }π@Exit: { we are finished. }πend { RPos };ππbeginπ s1 := ParamStr( 1 );π s2 := ParamStr( 2 );π writeln( RPos( s1, s2 ) );πend.ππ{πIf a '#' (shift-3) appears in the assembler source code, please replaceπthat by a at-sign (shift-2).π} 16 08-25-9409:12ALL JOSE CAMPIONE FASTEST Uppercase SWAG9408 rÉσ1 24 ^& π (*ππ For the SWAGS...ππ To the best of my knowledge this is the fastest routine for π up/low-casing strings in Turbo Pascal. The difference from π previous versions is that it uses seges for segment override π and within the loop it replaces loadsb and stosb with mov π operations. It is also independent from the segment in which π Source and Table are created. π π If anyone finds a bug or has a suggestion, or has a faster π looking routine for string translations, just leave me a π message here. I'll benchmark the new routine against the π collection I have gathered already from the SWAGS and π elsewhere and will post the results. ππ The following benchmarking was done in a 486/DX 60 MHz using π Neil Rubenking's TimeTick unit while upcasing a full string π (255 chars) 400,000 times (100 million characters): ππ For-Do loop using TP7 UpCase() .......... 315.5 secs.π UpperCase (Assembler classical approach) 53.9 secs. (1)π My old TXlat3 ........................... 28.3 secs. (2)π Translate ............................... 26.8 secs. (3)π TXlat5 (the one in this message) ........ 21.2 secs.ππ (1) There are several routines using this approach in the π SWAGS. See also HAX 144 in PC-Techniques. π (2) See "St-case4.pas" in STRINGS.SWG, it contains an earlier π (and buggy...) version.π (3) See "Translate upper/lower case" in STRINGS.SWGππ -Jose-π Jose Campione, 1:163.513.3π *)ππ Program TXlate;ππ typeπ ByteArray = array[0..255] of byte;π varπ Source : string;π Table : ByteArray;π i : byte;ππ Procedure TXlat5(var Source: string; var Table: ByteArray);assembler;π asmπ mov dx, ds { save ds }π lds bx,Table { load ds:bx with Table address }π les di,Source { load es:di with Source address }π seges { override ds segment}π mov al,[di] { load al with length of source }π xor ah, ah { set ah to zero, we need a word for cx }π mov cx,ax { assign length of source to counter }π jcxz @end { if cx = 0 exit}π inc di { increment di & skip length byte on 1st pass }π @filter:π mov al,[di] { load byte in ax from es:di }π xlat { tan-xlat-e... }π mov [di],al { send byte to es:di }π inc di { increment di }π loop @filter { decrement cx and loop back if cx > 0 }π @end: mov ds, dx { restore ds }π end;ππ beginπ {...}π {Fill Table for UpCase translation}π for i:= 0 to 255 doπ if i in [$61..$7A] then Table[i]:= i - $20 else Table[i]:= i;π {...}π Source: 'this string is to be upcased ';π WriteLn(Source);π TXlat5(Source,Table);π WriteLn(Source);π {...}π end.ππ π 17 08-25-9409:12ALL EDDY THILLEMAN Trim Strings SWAG9408 I╪ò 50 ^& πprocedure White2Space( var Str: string; const WhiteSpace: string ); assembler;π { replace white space chars in Str by spacesπ the string WhiteSpace contains the chars to replace }πasm { setup }π cld { string operations forwards }π les di, str { ES:DI points to Str }π xor cx, cx { clear cx }π mov cl, [di] { length Str in cl }π jcxz @exit { if length of Str = 0, exit }π inc di { point to 1st char of Str }π mov dx, cx { store length of Str }π mov bx, di { pointer to Str }π lds si, WhiteSpace { DS:SI points to WhiteSpace }π mov ah, [si] { load length of WhiteSpace }ππ@start: cmp ah, 0 { more chars WhiteSpace left? }π jz @exit { no, exit }π inc si { point to next char WhiteSpace }π mov al, [si] { next char to hunt }π dec ah { ah counting down }π xor dh, dh { clear dh }π mov cx, dx { restore length of Str }π mov di, bx { restore pointer to Str }π mov dh, ' ' { space char }π@scan:π repne scasb { the hunt is on }π jnz @next { white space found? }π mov [di-1], dh { yes, replace that one }π#next: jcxz @start { if no more chars in Str }π jmp @scan { if more chars in Str }π@exit:πend { White2Space };πππprocedure Trim( var Str: string ); assembler;π { remove trailing and leading spaces from str }πasm { setup }π les di, str { ES:DI points to Str }π lds si, str { DS:SI points to Str }π xor cx, cx { clear cx }π mov cl, [di] { length Str in cl }π jcxz @exit { if length of Str = 0, exit }π mov bx, di { bx points to length byte of Str }π xor dx, dx { clear dx }π mov al, ' ' { hunt for spaces }ππ { look for trailing spaces }π std { string operations backwards }π add di, cx { start with last char in Str }π repe scasb { the hunt is on }π jz @done { only spaces? }π inc cx { no, don't lose last char }ππ { look for leading spaces }π cld { string operations forward }π inc si { pointer to 1st char of Str }π mov di, si { pointer to 1st char of Str --> di }π repe scasb { the hunt is on }π jz @done { if only spaces, we are done }π inc cx { no, don't lose 1st non-blank char }π dec di { no, don't lose 1st non-blank char }π mov dx, cx { new lenght of Str }π xchg di, si { swap si and di }π rep movsb { move remaining part of Str }π@done: mov [bx], dl { new length of Str }π@exit:πend { Trim };ππprocedure RTrim( var Str: string ); assembler;π { remove trailing spaces from str }πasm { setup }π std { string operations backwards }π les di, str { ES:DI points to Str }π xor cx, cx { clear cx }π mov cl, [di] { length Str in cl }π jcxz @exit { if length of Str = 0, exit }π mov bx, di { bx points to Str }π add di, cx { start with last char in Str }π mov al, ' ' { hunt for spaces }ππ { remove trailing spaces }π repe scasb { the hunt is on }π jz @done { only spaces? }π inc cx { no, don't lose last char }π@done: mov [bx], cl { overwrite length byte of Str }π@exit:πend { RTrim };πππprocedure LTrim( var Str: string ); assembler;π { remove leading white space from str }πasm { setup }π cld { string operations forward }π lds si, str { DS:SI points to Str }π xor cx, cx { clear cx }π mov cl, [si] { length Str --> cl }π jcxz @exit { if length Str = 0, exit }π mov bx, si { save pointer to length byte of Str }π inc si { 1st char of Str }π mov di, si { pointer to 1st char of Str --> di }π mov al, ' ' { hunt for spaces }π xor dx, dx { clear dx }ππ { look for leading spaces }π repe scasb { the hunt is on }π jz @done { if only spaces, we are done }π inc cx { no, don't lose 1st non-blank char }π dec di { no, don't lose 1st non-blank char }π mov dx, cx { new lenght of Str }π xchg di, si { swap si and di }π rep movsb { move remaining part of Str }π@done: mov [bx], dl { new length of Str }π@exit:πend { LTrim };ππ 18 08-26-9407:26ALL BRUCE J. LACKORE Boolean String Search SWAG9408 ╦ÿüü 246 ^& Unit BoolPos;π{$Define Test}π{ Once debugging is complete, remove the above line to turn off debug mode. }ππ{ Version 1.3.5.P.ππ Requires Borland Turbo Pascal version 6.0 or later to compile.ππ Author: Bruce J. Lackore. Created Friday, July 23, 1993.π Copyright (c) 1993 Bruce J. Lackore. ALL RIGHTS RESERVED.π}ππ{$IFDEF Test}π {$A+,B-,D+,F-,G-,I+,L+,O-,R+,S+,V-,X+}π{$ELSE}π {$A+,B-,D-,F-,G-,I-,L-,O-,R-,S-,V-,X+}π{$ENDIF}ππ{ This unit comprises a function capable of searching a string for multipleπ occurences of substrings using Boolean operators. In the search string,π Boolean operators And and Or are defined as follows:ππ & - Andπ | - Orππ Parentheses are supported for doing multiple searches. Search strings areπ submitted as follows:ππ i.e. In the source string "The quick brown fox jumped over the lazy dog"π and the search is for the word blue and the words quick or fox,π the search string is entered as follows:ππ (blue&(quick|fox))ππ The way the function is currently written, And (&) and Or (|) have the sameπ precedence level hence the above search string without parentheses would beπ interpretted to be (blue&quick|fox):ππ blue And quick would be searched for first, the result Or'd with theπ results of the search for fox.ππ Notice the difference in that (blue&(quick|fox)) is a False statement whilstπ (blue&quick|fox) is True.ππ The function will automatically scan for () pairs, adding the necessary )π at the end of the search string or ( at the beginning if required.ππ The function will also search for (|, |), (& and &) symbols, these beingπ illegal.ππ It should also be noted that although excess parens will not cause theπ function to fail, they DO cause the function to loop unnecessarily throughπ the token search (once for each set of parens) while bringing the finalπ answer out of the final set of parens.ππ}ππ{ Bug fixes:ππ 07/04/1994: Thought the 06/01 fix did the job. It didn't. This time,π I went back into the token processor and found that it wasπ missing a left paren when the tokenized search string was inπ the form of (b@b...)@(b@b...) where b is a boolean designatorπ (T or F) and @ is a boolean operator (| or &). Thanx toπ Michael Jarmulowicz for pointing this out.π The fix was to go into the Process_token_str function andπ ensure that a multi-pass required token string has sufficientπ parens so as to not confuse the token processor.π Also defined BPos return value should the Fixup_srch_strπ function fail. The default is False (as set in the firstπ line of the BPos function itself) and is triggered byπ Fixup_srch_str returning a null string. Removed the "fix"π that was suggested in the 06/01 bug fix and replaced it withπ code that scans the first and last letters of the Srch_strπ to ensure that they are parens, if not, add a pair.ππ 06/01/1994: After returning from WestPac, I received a couple of emailsπ telling me that if the function was called with NOπ parentheses, it would fail. The fix is simply to add a set ofπ parens in the Fixup_srch_str function just before theπ function returns if the first character of the Srch_str is NOTπ a left paren equivalent. I have had one report of the unitπ not working in protected mode. As I don't yet know much aboutπ protected mode programming, I am still working on thatπ particular bug but I WILL fix it if the error is in here. Iπ also tightened up one of the assembly replacement functions,π see the docs for the change.ππ 10/04/1993: Noticed that length of Src_str in function Next_CPos wasπ incorrectly calculated because of positioning of INC DI.π INC DI precedes the MOV CL,[ES:DI] causing the function toπ consider the first character of Src_str to represent theπ length rather than the actual length byte. Fix is to moveπ the INC DI to the line following the MOV CL,[ES:DI].ππ}ππInterfaceππFunction BPos(Srch_str, Src_str: String; Ignore_case: Boolean): Boolean;ππ{ This function accepts a source string and a search string as described aboveπ and returns a Boolean value based on whether or not the parsed searchπ string was found.π}ππ{ ************************************************************************** }ππImplementationππConstπ Lt_pn: Char = '(';π Rt_pn: Char = ')';ππFunction Cnt_ch(Scan_char: Char; In_str: String): Byte; Assembler;ππ{ This function will scan a string for occurences of a particular character.π The function will return the number of occurences.π}ππ Asm { Function Cnt_ch }π XOR AX,AX { 0 AX }π MOV BL,Scan_char { Put char to count in BL }π LES SI,In_str { Set ES:SI to point to start of string }π XOR CX,CX { 0 CX }π MOV CL,[ES:SI] { Move string length to CX }π ADD SI,CX { Set ES:SI to point to END of string }π @LOOK: CMP BL,[ES:SI] { Start Loop, compare current char and BL }π JNE @NEXT { If not equal, jump to end of loop }π INC AX { If equal, Inc char cnt (AX) }π @NEXT: DEC SI { Set ES:SI back one character }π LOOP @LOOK { Decrement CX and jump to start of loop }π End; { Function Cnt_ch }ππFunction Fill_str(Dupe_ch: Char; How_many: Byte): String; Assembler;ππ{ This function returns How_many of Dupe_char.π}ππ Asm { Function Fill_str }π LES DI, @Result { Set ES:DI to function result area }π CLD { Clear direction flag }π XOR CH,CH { 0 CH }π MOV CL,How_many { Length in CX }π MOV AX,CX { and in AX }π STOSB { Store length byte }π MOV AL,Dupe_ch { Put char to dupe in AL }π REP STOSB { Fill string with char }π End; { Function Fill_str }ππFunction PosC(Srch_ch: Char; Src_str: String): Boolean; Assembler;ππ{ This function is similar to the Pos function of Pascal except that itπ accepts only a single character to search for. This function returns aπ True if a Srch_ch is encountered, a False if not.π}ππ Asm { Function PosC }π XOR BX,BX { 0 BX }π MOV AL,Srch_ch { Put char to look for in AL }π LES DI,Src_str { Set ES:DI to start of Src_str }π XOR CX,CX { 0 CX }π MOV CL,[ES:DI] { Store length of Src_str in CL }π ADD DI,CX { Set ES:DI to end of string }π STD { Set direction flag }π @LOOK: REPNZ SCASB { Look for AL in Src_str }π JNZ @DONE { If not found, jump to end (BX = 0) }π INC BX { If Found, Inc Bx to 1 = Pascal True }π @DONE: MOV AX,BX { Move BX to AX (return result) }π End; { Function PosC }ππFunction Last_Cpos(Srch_ch: Char; Src_str: String): Byte; Assembler;ππ{ This function performs the same function as the Pascal POS function exceptπ that it works only with a single character and rather than returning theπ first position the character is found in, it returns the LAST position thatπ the search character is found in.π}ππ Asm { Function Last_Cpos }π MOV AL,Srch_ch { Put char to look for in AL }π LES DI,Src_str { Set ES:DI to start of Src_str }π XOR CX,CX { 0 CX }π MOV CL,[ES:DI] { Move length of Src_str to CL }π ADD DI,CX { Set ES:DI to end of Src_str }π INC CX { Add one to CX (correct for string length }π STD { Set direction flag }π REPNZ SCASB { Look for character in string }π MOV AX,CX { If found CX indicates position, else 0 }π End; { Function Last_Cpos }ππFunction Next_CPosπ (Srch_ch: Char; Src_str: String; Strt_at: Byte): Byte; Assembler;ππ{ This function searches for the next occurence of Srch_ch in Src_str AFTERπ position Strt_at. The function returns the offset from the beginning ofπ the string, NOT the offset from Strt_at.π}ππ Asm { Function Next_CPos }π XOR AX,AX { 0 AX }π MOV AL,Strt_at { Move position to start at to AL }π LES DI,Src_str { Set ES:DI to start of Src_str }π XOR CX,CX { 0 CX }π MOV CL,[ES:DI] { Store length of Src_str in CL }π INC DI { Set ES:DI to first char of Src_str }π MOV BX,CX { Move CX to BX }π SUB CX,AX { Set CX to length of string after Strt_at }π ADD DI,AX { Set ES:DI to char at Strt_at in Src_str }π MOV AL,Srch_ch { Move Srch_ch to AL }π CLD { Clear direction flag }π REPNZ SCASB { Look for character following Strt_at }π JNZ @NOTFND { If not found, jump to end of procedure }π SUB BX,CX { Set BX to position char found in }π JMP @DONE { Jump to end of procedure }π @NOTFND: XOR BX,BX { Srch_ch not found, set BX to 0 }π @DONE: MOV AX,BX { Move position found at (BX) to AX }π End; { Function Next_CPos }ππ{$F+}πFunction Up_cs(In_str: String): String;ππ{ This function converts In_str to all upper case characters.π}ππ Begin { Function Up_cs }π Inline(π $1E/ { PUSH DS }π $C4/$7E/$0A/ { LES DI,[BP+$0A] }π $C5/$76/$06/ { LDS SI,[BP+$06] }π $30/$E4/ { XOR AH,AH }π $AC/ { LODSB }π $AA/ { STOSB }π $89/$C1/ { MOV CX,AX }π $E3/$0F/ { JCXZ DONE }π $FC/ { CLD }π $AC/ {DOCHAR: LODSB }π $3C/$61/ { CMP AL,'a' }π $72/$06/ { JB NEXTCH }π $3C/$7A/ { CMP AL,'z' }π $77/$02/ { JA NEXTCH }π $24/$DF/ { AND AL,$DF }π $AA/ {NEXTCH: STOSB }π $E2/$F2/ { LOOP DOCHAR }π $1F) {DONE: POP DS }π End; { Function Up_cs }π{$F-}ππFunction Fixup_srch_str(Srch_str: String): String;ππ{ This functions sole purpose in life is to count the number of paranthesesπ pairs and correct for a deficient number of either by adding the appropriateπ character either at the beginning or the end of the search string. Thisπ may not yield the correct result as the searcher intended but is aπ requirement of the algorithm (it searches for paran pairs). Note that theπ function will add one set of parantheses if none are found. This functionπ also looks for illegal character pairs (&, &), (| and |), these pairsπ indicate an illegal Boolean search. The function returns the correctedπ Srch_str if all is well, an empty string if not.π}ππ Varπ Left_para,π Right_para,π How_many: Integer;ππ Begin { Function Fixup_srch_str }π If (Srch_str[Length(Srch_str)] <> Rt_pn) Or (Srch_str[1] <> Lt_pn) Thenπ Srch_str := Lt_pn + Srch_str + Rt_pn;π Left_para := Cnt_ch(Lt_pn, Srch_str); { Count the parens }π Right_para := Cnt_ch(Rt_pn, Srch_str);π How_many := Abs(Left_para - Right_para); { Get the difference }π If How_many > 0 Thenπ If Right_para < Left_para Thenπ Srch_str := Srch_str + Fill_str(Rt_pn, How_many)π Elseπ Srch_str := Fill_str(Lt_pn, How_many) + Srch_str;π If (Pos(Lt_pn + '&', Srch_str) <> 0) Or { Illegal call? }π (Pos('&' + Rt_pn, Srch_str) <> 0) Orπ (Pos(Lt_pn + '|', Srch_str) <> 0) Orπ (Pos('|' + Rt_pn, Srch_str) <> 0) Thenπ Fixup_srch_str := ''π Elseπ Fixup_srch_str := Srch_str { All is well }π End; { Function Fixup_srch_str }ππFunction Parse_srch_str(Srch_str, Src_str: String): String;ππ{ This function simply extracts each string to search for, tests to see ifπ it exists in the original string and replaces the extracted substring withπ the appropriate token. It should be noted that each substring is determinedπ solely by the characters used for parantheses and operators. Any otherπ characters are assumed to be part of the search string.ππ Each substring is searched for in the original Search_str and its presenseπ or absense noted with a T or F respectively.π}ππ Varπ Rtn_str,π Token_str: String;π End_token: Boolean;ππ Begin { Function Parse_srch_str }π Token_str := '';π Rtn_str := '';π While Srch_str <> '' Doπ Beginπ If (Srch_str[1] In [Lt_pn, Rt_pn, '&', '|']) Then { Token starts? }π Beginπ End_token := (Token_str <> ''); { End of token? If not }π If Not(End_token) Then { then start one. }π Rtn_str := Rtn_str + Srch_str[1]π Endπ Elseπ Beginπ Token_str := Token_str + Srch_str[1]; { Add a char to substring }π End_token := Falseπ End;π If End_token Then { If complete token, look }π Begin { for it in the source str }π If Pos(Token_str, Src_str) <> 0 Thenπ Rtn_str := Rtn_str + 'T' { If found, return T }π Elseπ Rtn_str := Rtn_str + 'F'; { If not, return F }π Rtn_str := Rtn_str + Srch_str[1];π Token_str := ''; { Reset to look for more }π End_token := Falseπ End; { If End_token }π Delete(Srch_str, 1, 1) { Delete the char justπ processed and start againπ }π End; { While Srch_str <> '' }π Parse_srch_str := Rtn_strπ End; { Function Parse_srch_str }ππFunction Process_token_str(Token_str: String): Char;ππ Varπ One_token: String;π One_token_len,π Left_para: Byte;ππ Function Process_one_token_str(The_token: String): Char;ππ Varπ Lcv: Byte;π Curr_answer,π Do_and: Boolean;ππ Begin { Function Process_one_token_str }π Curr_answer := (The_token[1] = 'T'); { Establish current answerπ by checking first token.π }π For Lcv := 2 to Length(The_token) Do { Look at the rest of theπ token str.π }π Case The_token[Lcv] of { Boolean op is And }π '&': Do_and := True; { Boolean op is Or }π '|': Do_and := False;π 'T': If Do_and Thenπ Curr_answer := Curr_answer And True { If And }π Elseπ Curr_answer := True; { If Or }π 'F': If Do_and Then { If And (Or stays T) }π Curr_answer := False;π End; { Case }π If Curr_answer Then { Final result }π Process_one_token_str := 'T'π Elseπ Process_one_token_str := 'F'π End; { Function Process_one_token_str }ππ Begin { Function Process_token_str }ππ { Are parens present? If so process as tokenized phrase, if not, finalπ result has been received or can be processed in a single pass.π }ππ If PosC(Lt_pn, Token_str) Thenπ Beginπ While Length(Token_str) > 1 Doπ Beginππ { Ensure that the token has enough parens to not confuse theπ token string processor. One need only check for a left parenπ since the Fixup_srch_str function ensures that an equal numberπ of paren PAIRS exists.π }ππ If Not(PosC(Lt_pn, Token_str)) Thenπ Token_str := Lt_pn + Token_str + Rt_pn;ππ { Find leftmost left paren }ππ Left_para := Last_Cpos(Lt_pn, Token_str);πππ { Find first right paren after leftmost left paren }ππ One_token_len :=π Succ(Next_CPos(Rt_pn, Token_str, Left_para) - Left_para);ππ { Copy everything between the two }ππ One_token := Copy(Token_str, Left_para, One_token_len);ππ { Remove the parens }ππ Dec(One_token[0]);π Delete(One_token, 1, 1);ππ { Remove the original substring from the phrase }ππ Delete(Token_str, Left_para, One_token_len);ππ { Insert the resultant single character in place of the oldπ substring.π }ππ Insert(Process_one_token_str(One_token), Token_str, Left_para)π End; { While Length(Token_str) > 1 }π Process_token_str := Token_str[1]π Endπ Elseπ Process_token_str := Process_one_token_str(One_token)π End; { Function Process_token_str }ππFunction BPos;ππ Begin { Function BPos }π BPos := False;π If Ignore_case Thenπ Beginπ Srch_str := Up_cs(Srch_str);π Src_str := Up_cs(Src_str)π End; { If Ignore_case }ππ { Is this a Boolean expression? If so process with this function, elseπ process with Pascal POS function.π }ππ If PosC('|', Srch_str) Or PosC('&', Srch_str) Thenπ Beginπ Srch_str := Parse_srch_str(Fixup_srch_str(Srch_str), Src_str);π If Srch_str <> '' Thenπ BPos := (Process_token_str(Srch_str) = 'T')π Endπ Elseπ BPos := Pos(Srch_str, Src_str) <> 0π End; { Function BPos }ππEnd. { Unit BoolPos }ππProgram Test;π{$Define test}ππ{ Version 1.0.0.Tππ Requires Borland Turbo Pascal version 6.0 or later to compile.ππ Author: Bruce J. Lackore. Created Monday, June 13, 1994.π Copyright (c) 1994 Bruce J. Lackore. ALL RIGHTS RESERVED.π}ππ{$IFDEF Test}π {$A+,B-,D+,E+,F-,G-,I+,L+,N-,R+,S+,V-,X+}π{$ELSE}π {$A+,B-,D-,E+,F-,G-,I-,L-,N-,R-,S-,V-,X+}π{$ENDIF}ππ{$M 16384, 0, 655360}ππ{ This is a quick and really dirty test program for the Boolpos unit. Justπ tinker with the search phrase in line 3 of the code and enjoy!π}ππUses Boolpos;ππVarπ BResult: Boolean;π Src_str: String;ππProcedure Start_program;ππ Begin { Procedure Start_program }π BResult := False;π Src_str := 'Now is the time for all good programmers to switch to OS/2';π BResult := BPos('(Now&then)|(time&bad)', Src_str, False)π End; { Procedure Start_program }ππBegin { Program: Test }π Start_program;πEnd. { Program: Test }
